home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / trace.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-06-18  |  13.0 KB  |  315 lines
  1. ;; Tracer
  2. ;; Bruno Haible 13.2.1990, 15.3.1991, 4.4.1991
  3.  
  4. ; (TRACE) liefert Liste der getraceten Funktionen
  5. ; (TRACE fun ...) tracet die Funktionen fun, ... zusΣtzlich.
  6. ; Format fⁿr fun:
  7. ;   Entweder ein Symbol
  8. ;        symbol
  9. ;   oder eine Liste aus einem Symbol und einigen Keyword-Argumenten (paarig!)
  10. ;        (symbol
  11. ;          [:suppress-if form]   ; kein Trace-Output, solange form erfⁿllt ist
  12. ;          [:step-if form]       ; Trace geht in den Stepper, falls form erfⁿllt
  13. ;          [:pre form]           ; fⁿhrt vor Funktionsaufruf form aus
  14. ;          [:post form]          ; fⁿhrt nach Funktionsaufruf form aus
  15. ;          [:pre-break-if form]  ; Trace geht vor Funktionsaufruf in die Break-Loop,
  16. ;                                ; falls form erfⁿllt
  17. ;          [:post-break-if form] ; Trace geht nach Funktionsaufruf in die Break-Loop,
  18. ;                                ; falls form erfⁿllt
  19. ;          [:pre-print form]     ; gibt die Werte von form vor Funktionsaufruf aus
  20. ;          [:post-print form]    ; gibt die Werte von form nach Funktionsaufruf aus
  21. ;          [:print form]         ; gibt die Werte von form vor und nach Funktionsaufruf aus
  22. ;        )
  23. ;   In all diesen Formen kann auf *TRACE-FUNCTION* (die Funktion selbst)
  24. ;   und *TRACE-ARGS* (die Argumente an die Funktion)
  25. ;   und *TRACE-FORM* (der Funktions-/Macro-Aufruf als Form)
  26. ;   und nach Funktionsaufruf auch auf *TRACE-VALUES* (die Liste der Werte
  27. ;   des Funktionsaufrufs) zugegriffen werden,
  28. ;   und mit RETURN kann der Aufruf mit gegebenen Werten verlassen werden.
  29. ; (UNTRACE) liefert Liste der getraceten Funktionen, streicht sie alle.
  30. ; (UNTRACE symbol ...) streicht symbol, ... aus der Liste der getraceten
  31. ;   Funktionen.
  32. ; TRACE und UNTRACE sind auch auf Funktionen (SETF symbol) und auf Macros anwendbar,
  33. ;   nicht jedoch auf lokal definierte Funktionen und Macros.
  34.  
  35. (in-package "LISP")
  36. (export '(trace untrace
  37.           *trace-function* *trace-args* *trace-form* *trace-values*
  38. )        )
  39. (in-package "SYSTEM")
  40.  
  41. (proclaim '(special *trace-function* *trace-args* *trace-form* *trace-values*))
  42. (defvar *traced-functions* nil) ; Liste der momentan getraceden Funktionsnamen
  43.   ; Solange ein Funktionsname funname [bzw. genauer: das Symbol
  44.   ; symbol = (get-funname-symbol funname)] getraced ist, enthΣlt
  45.   ; die Property sys::traced-definition den alten Inhalt der Funktionszelle,
  46.   ; die Property sys::tracing-definition den neuen Inhalt der Funktionszelle,
  47.   ; und ist der Funktionsname Element der Liste *traced-functions*.
  48.   ; WΣhrenddessen kann sich der Inhalt der Funktionszelle jedoch Σndern!
  49.   ; Jedenfalls gilt stets:
  50.   ;        (and (fboundp symbol)
  51.   ;             (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  52.   ;        )
  53.   ; ===>   (member funname *traced-functions* :test #'equal)
  54.   ; <==>   (get symbol 'sys::traced-definition)
  55. (defvar *trace-level* 0) ; Verschachtelungstiefe bei der Trace-Ausgabe
  56.  
  57. ; Funktionen, die der Tracer zur Laufzeit aufruft und die der Benutzer
  58. ; tracen k÷nnte, mⁿssen in ihrer ungetraceden Form aufgerufen werden.
  59. ; Statt (fun arg ...) verwende daher (SYS::%FUNCALL '#,#'fun arg ...)
  60. ; oder (SYS::%FUNCALL (LOAD-TIME-VALUE #'fun) arg ...).
  61. ; Dies gilt fⁿr alle hier verwendeten Funktionen von #<PACKAGE LISP> au▀er
  62. ; CAR, CDR, CONS, APPLY, VALUES-LIST (die alle inline compiliert werden).
  63.  
  64. (defmacro trace (&rest funs)
  65.   (if (null funs)
  66.     '*traced-functions*
  67.     (cons 'append
  68.       (mapcar #'(lambda (fun)
  69.                   (if (or (atom fun) (function-name-p fun))
  70.                     (trace1 fun)
  71.                     (apply #'trace1 fun)
  72.                 ) )
  73.               funs
  74.     ) )
  75. ) )
  76.  
  77. (defun trace1 (funname &key (suppress-if nil) (step-if nil)
  78.                             (pre nil) (post nil)
  79.                             (pre-break-if nil) (post-break-if nil)
  80.                             (pre-print nil) (post-print nil) (print nil)
  81.                        &aux (old-function (gensym)) (macro-flag (gensym))
  82.               )
  83.   (unless (function-name-p funname)
  84.     (error-of-type 'program-error
  85.       (DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  86.        ENGLISH "~S: function name should be a symbol, not ~S"
  87.        FRANCAIS "~S : Le nom de la fonction doit Ωtre un symbole et non ~S")
  88.       'trace funname
  89.   ) )
  90.   (let ((symbolform
  91.           (if (atom funname)
  92.             `',funname
  93.             `(load-time-value (get-setf-symbol ',(second funname)))
  94.        )) )
  95.     `(block nil
  96.        (unless (fboundp ,symbolform) ; Funktion ⁿberhaupt definiert?
  97.          (warn (DEUTSCH "~S: Funktion ~S ist nicht definiert."
  98.                 ENGLISH "~S: undefined function ~S"
  99.                 FRANCAIS "~S : La fonction ~S n'est pas dΘfinie.")
  100.                'trace ',funname
  101.          )
  102.          (return nil)
  103.        )
  104.        (when (special-form-p ,symbolform) ; Special-Form: nicht tracebar
  105.          (warn (DEUTSCH "~S: Special-Form ~S kann nicht getraced werden."
  106.                 ENGLISH "~S: cannot trace special form ~S"
  107.                 FRANCAIS "~S : La forme spΘciale ~S ne peut pas Ωtre tracΘe.")
  108.                'trace ',funname
  109.          )
  110.          (return nil)
  111.        )
  112.        (let* ((,old-function (symbol-function ,symbolform))
  113.               (,macro-flag (consp ,old-function)))
  114.          (unless (eq ,old-function (get ,symbolform 'sys::tracing-definition)) ; schon getraced?
  115.            (setf (get ,symbolform 'sys::traced-definition) ,old-function)
  116.            (pushnew ',funname *traced-functions* :test #'equal)
  117.          )
  118.          (format t (DEUTSCH "~&;; ~:[Funktion~;Macro~] ~S wird getraced."
  119.                     ENGLISH "~&;; Tracing ~:[function~;macro~] ~S."
  120.                     FRANCAIS "~&;; Traτage ~:[de la fonction~;du macro~] ~S.")
  121.                    ,macro-flag ',funname
  122.          )
  123.          (replace-in-fenv (get ,symbolform 'sys::traced-definition) ',funname
  124.            ,old-function
  125.            (setf (get ,symbolform 'sys::tracing-definition)
  126.              (setf (symbol-function ,symbolform)
  127.                ; neue Funktion, die die ursprⁿngliche ersetzt:
  128.                ,(let ((newname (concat-pnames "TRACED-" (get-funname-symbol funname)))
  129.                       (body
  130.                         `((declare (compile) (inline car cdr cons apply values-list))
  131.                           (let ((*trace-level* (trace-level-inc)))
  132.                             (block nil
  133.                               (unless ,suppress-if
  134.                                 (trace-pre-output)
  135.                               )
  136.                               ,@(when pre-print
  137.                                   `((trace-print (multiple-value-list ,pre-print)))
  138.                                 )
  139.                               ,@(when print
  140.                                   `((trace-print (multiple-value-list ,print)))
  141.                                 )
  142.                               ,pre
  143.                               ,@(when pre-break-if
  144.                                   `((when ,pre-break-if (sys::break-loop t)))
  145.                                 )
  146.                               (let ((*trace-values*
  147.                                       (multiple-value-list
  148.                                         (if ,step-if
  149.                                           (trace-step-apply)
  150.                                           (apply *trace-function* *trace-args*)
  151.                                    )) ) )
  152.                                 ,@(when post-break-if
  153.                                     `((when ,post-break-if (sys::break-loop t)))
  154.                                   )
  155.                                 ,post
  156.                                 ,@(when print
  157.                                     `((trace-print (multiple-value-list ,print)))
  158.                                   )
  159.                                 ,@(when post-print
  160.                                     `((trace-print (multiple-value-list ,post-print)))
  161.                                   )
  162.                                 (unless ,suppress-if
  163.                                   (trace-post-output)
  164.                                 )
  165.                                 (values-list *trace-values*)
  166.                          )) ) )
  167.                      ))
  168.                   `(if (not ,macro-flag)
  169.                      (function ,newname
  170.                        (lambda (&rest *trace-args*
  171.                                 &aux (*trace-form* (make-apply-form ',funname *trace-args*))
  172.                                      (*trace-function* (get-traced-definition ,symbolform))
  173.                                )
  174.                          ,@body
  175.                      ) )
  176.                      (cons 'sys::macro
  177.                        (function ,newname
  178.                          (lambda (&rest *trace-args*
  179.                                   &aux (*trace-form* (car *trace-args*))
  180.                                        (*trace-function* (cdr (get-traced-definition ,symbolform)))
  181.                                  )
  182.                            ,@body
  183.                      ) ) )
  184.                    )
  185.                 )
  186.        ) ) ) )
  187.        '(,funname)
  188.      )
  189. ) )
  190.  
  191. ;; Hilfsfunktionen:
  192. ; Funktionsreferenzen, die vom LABELS bei DEFUN kommen, ersetzen:
  193. (defun replace-in-fenv (fun funname old new)
  194.   (when (and (sys::closurep fun) (not (compiled-function-p fun)))
  195.     ; interpretierte Closure
  196.     (let ((fenv (sys::%record-ref fun 5))) ; Funktions-Environment
  197.       (when fenv ; falls nichtleer, durchlaufen:
  198.         (do ((l (length fenv)) ; l = 2 * Anzahl der Bindungen + 1
  199.              (i 1 (+ i 2)))
  200.             ((eql i l))
  201.           (when (and (equal (svref fenv (- i 1)) funname) (eq (svref fenv i) old))
  202.             (setf (svref fenv i) new)
  203.         ) )
  204. ) ) ) )
  205. ; NΣchsth÷heres Trace-Level liefern:
  206. (defun trace-level-inc ()
  207.   (%funcall '#,#'1+ *trace-level*)
  208. )
  209. ; Ursprⁿngliche Funktionsdefinition holen:
  210. (defun get-traced-definition (symbol)
  211.   (%funcall '#,#'get symbol 'sys::traced-definition)
  212. )
  213. ; Anwenden, aber durchsteppen:
  214. (defun trace-step-apply ()
  215.   ;(eval `(step (apply ',*trace-function* ',*trace-args*)))
  216.   (%funcall '#,#'eval
  217.     (cons 'step
  218.      (cons
  219.        (cons 'apply
  220.         (cons (cons 'quote (cons *trace-function* nil))
  221.          (cons (cons 'quote (cons *trace-args* nil))
  222.           nil
  223.        )))
  224.       nil
  225.     ))
  226.   )
  227. )
  228. ; Eval-Form bauen, die einem Apply (nΣherungsweise) entspricht:
  229. (defun make-apply-form (funname args)
  230.   (declare (inline cons mapcar))
  231.   (cons funname
  232.     (mapcar #'(lambda (arg)
  233.                 ;(list 'quote arg)
  234.                 (cons 'quote (cons arg nil))
  235.               )
  236.             args
  237.   ) )
  238. )
  239. ; Output vor Aufruf, benutzt *trace-level* und *trace-form*
  240. (defun trace-pre-output ()
  241.   (%funcall '#,#'terpri *trace-output*)
  242.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  243.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  244.   (%funcall '#,#'prin1 *trace-form* *trace-output*)
  245. )
  246. ; Output nach Aufruf, benutzt *trace-level*, *trace-form* und *trace-values*
  247. (defun trace-post-output ()
  248.   (declare (inline car cdr consp atom))
  249.   (%funcall '#,#'terpri *trace-output*)
  250.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  251.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  252.   (%funcall '#,#'write (car *trace-form*) :stream *trace-output*)
  253.   (%funcall '#,#'write-string " ==> " *trace-output*)
  254.   (trace-print *trace-values* nil)
  255. )
  256. ; Output einer Liste von Werten:
  257. (defun trace-print (vals &optional (nl-flag t))
  258.   (when nl-flag (%funcall '#,#'terpri *trace-output*))
  259.   (when (consp vals)
  260.     (loop
  261.       (let ((val (car vals)))
  262.         (%funcall '#,#'prin1 val *trace-output*)
  263.       )
  264.       (setq vals (cdr vals))
  265.       (when (atom vals) (return))
  266.       (%funcall '#,#'write-string ", " *trace-output*)
  267. ) ) )
  268.  
  269. (defmacro untrace (&rest funs)
  270.   `(mapcan #'untrace1 ,(if (null funs) `(copy-list *traced-functions*) `',funs))
  271. )
  272.  
  273. (defun untrace1 (funname)
  274.   (unless (function-name-p funname)
  275.     (error-of-type 'program-error
  276.       (DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  277.        ENGLISH "~S: function name should be a symbol, not ~S"
  278.        FRANCAIS "~S : Le nom de la fonction doit Ωtre un symbole et non ~S")
  279.       'untrace funname
  280.   ) )
  281.   (let* ((symbol (get-funname-symbol funname))
  282.          (old-definition (get symbol 'sys::traced-definition)))
  283.     (prog1
  284.       (if old-definition
  285.         ; symbol war getraced
  286.         (progn
  287.           (if (and (fboundp symbol)
  288.                    (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  289.               )
  290.             (progn
  291.               (replace-in-fenv old-definition funname (symbol-function symbol) old-definition)
  292.               (setf (symbol-function symbol) old-definition)
  293.             )
  294.             (warn (DEUTSCH "~S: ~S war getraced und wurde umdefiniert!"
  295.                    ENGLISH "~S: ~S was traced and has been redefined!"
  296.                    FRANCAIS "~S : ~S Θtait tracΘe et a ΘtΘ redΘfinie!")
  297.                   'untrace funname
  298.           ) )
  299.           `(,funname)
  300.         )
  301.         ; funname war nicht getraced
  302.         '()
  303.       )
  304.       (untrace2 funname)
  305. ) ) )
  306.  
  307. (defun untrace2 (funname)
  308.   (let ((symbol (get-funname-symbol funname)))
  309.     (remprop symbol 'sys::traced-definition)
  310.     (remprop symbol 'sys::tracing-definition)
  311.   )
  312.   (setq *traced-functions* (delete funname *traced-functions* :test #'equal))
  313. )
  314.  
  315.